perm filename NODES.SAI[HAL,HE] blob
sn#238945 filedate 1976-09-29 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00031 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 Bulk of code for POINTY or HAIRY.
C00008 00003 ! Macros to communicate with Handy and invoke Wave functions
C00012 00004 ! Procedures to handle blue arm
C00014 00005 ! cursor & arithmetic stack definition
C00018 00006 ! stack operations
C00023 00007 ! symbol table routines
C00026 00008 ! abort
C00028 00009 ! new_node, unlnk_node, is_ancestor, lnk_node, eldest_son
C00032 00010 ! copy_tree, controlled_by
C00034 00011 ! purge_id, fix_id
C00035 00012 ! some arithmetic on transform matrices
C00042 00013 ! some arithmetic on vectors
C00047 00014 ! arithmetic ops: tr,apush,apop,atop,tmul,tinv,tedit,oops
C00063 00015 ! absxf, setabsxf, absxfe
C00065 00016 ! afx_node
C00066 00017 ! node_csr, id_decode, nodespec, λ
C00070 00018 ! editing ops: mk_node, copy_node, name_node
C00072 00019 ! editing ops: affix_node, rigid, nonrigid, independent, merge
C00074 00020 ! editing ops: kill, unkill
C00076 00021 ! editing ops: godad,goson,elder,younger
C00078 00022 ! editing ops: cpush, cpop, ctop, cexch, crollup, crolldown
C00080 00023 ! editing ops: absloc, relloc, absset, relset
C00083 00024 ! motion operations
C00094 00025 ! macro operations for motion, pointit, grabbit, fdef
C00095 00026 ! altrans,alid, aldecs, unique_id
C00101 00027 ! code to emit a pointy command file
C00105 00028 ! dskin, macro routines, prompt, bcall
C00113 00029 ! tree_string, csr_string, astk_string
C00119 00030 ! display routines: tree_print,csr_print,update
C00123 00031 ! toplevel, exit
C00127 ENDMK
C⊗;
COMMENT Bulk of code for POINTY or HAIRY.;
REQUIRE "ABBREV.SAI[HAL,HE]" SOURCE_FILE;
REQUIRE "MACROS.SAI[HAL,HE]" SOURCE_FILE;
IFCR NOT DECLARATION(BVERS) THENC DEFINE BVERS=TRUE; ENDC
IFCR NOT DECLARATION(YVERS) THENC DEFINE YVERS=NOT BVERS; ENDC
IFCR NOT DECLARATION(HAIRY_VERSION) THENC DEFINE HAIRY_VERSION=TRUE; ENDC
IFCR NOT DECLARATION(PJ) THENC DEFINE PJ=FALSE; ENDC
IFCR YVERS THENC
REQUIRE "YELLOW ARM VERSION" MESSAGE;
REQUIRE "PREAMB.SAI[SYS,HE]" SOURCE_FILE;
ENDC
REQUIRE IFCR HAIRY_VERSION THENC " HAIRY" ELSEC " POINTY" ENDC MESSAGE;
IFCR BVERS THENC
REQUIRE " BLUE ARM VERSION" MESSAGE;
ENDC
REQUIRE "RECAUX.HDR[HAL,HE]" SOURCE_FILE;
REQUIRE "DPYSUB.HDR[1,PDQ]" SOURCE_FILE;
FORWARD PROCEDURE ABORT(STRING MSG);
IFCR HAIRY_VERSION THENC
RCLASS NODE(STRING PNAME;RANY DAD,SON,EBRO,YBRO;
INTEGER HOWLINKED;
REAL ARRAY XF;
INTEGER KIND;
RPTR(ANY_CLASS) INFO);
ELSEC
RCLASS NODE(STRING PNAME;RANY DAD,SON,EBRO,YBRO;
INTEGER HOWLINKED;
REAL ARRAY XF);
ENDC
! XF[1:3,1:3] = rotation matrix.
XF[1:3,4] = translation vector.
XF[4,1:3] = 0.
XF[4,4] = 1.0.
XF[5,1:3] = rotation angles.
XF[5,4] > 0 if angles are valid.
;
RCLASS XFELT(REAL ARRAY XF);
RCLASS VECTOR(REAL X,Y,Z);
RCLASS SCALAR(REAL VAL);
FORWARD RPTR(XFELT) PROCEDURE NEW_XFELT;
DEFINE INDLNK = 0; ! independent;
DEFINE NRGLNK = 1; ! non-rigid affixment;
DEFINE RGDLNK = 2; ! rigid affixment;
RPTR(NODE) WORLD, ! the top of the tree;
ARM, ! current ARM location;
POINTER, ! current POINTER location;
FIDUCIAL; ! Fiducial frame;
FORWARD PROCEDURE UPDATE; ! updates display;
INTEGER UPDSUPPRESS; ! if >0 then do not display;
INTEGER ALCH,ALEOF; ! channel number for AL output;
STRING ALFID;
INITIALIZE(ALCH←-1);
INTEGER PCH,PCEOF; ! channel number for pointy commands;
STRING PCFID;
INITIALIZE(PCH←-1);
DEFINE DEG = "(π/180.0)";
DEFINE ALT = '175; ! **** The losing Stanford ALTMODE ****;
DEFINE INCHES = "1.0"; ! how the world is calibrated now;
REAL DEGREES; INITIALIZE(DEGREES←DEG);
REAL TINY; INITIALIZE(TINY←0.01);
REQUIRE 600 SYSTEM_PDL;
! Macros to communicate with Handy and invoke Wave functions;
IFCR YVERS THENC
SMP TO_ARM(REAL ARRAY T;REFERENCE INTEGER FLAG);
INTEGER ARMFLAG;
DEFINE α(S) "[]" = [ISSUE(7,"NODES","HANDY",MESSAGE S)];
! MACROS TO START, END, AND DO TRAJECTORIES;
DEFINE βSTART "[]" = [α(START_TRAJECTORY("TEMP",0))];
DEFINE βEND "[]" = [α(CLOSE_TRAJECTORY)];
DEFINE βDO "[]" = [α(DO_IT(0,"TEMP"))];
DEFINE βBLOCK(S) "[]" = [BEGIN
S
END];
DEFINE βEXEC(S) "[]" = [βBLOCK(βSTART;
S;
βEND;
βDO)];
! MACROS TO MIMIC WAVE;
DEFINE βMERGE "[]" = [α(MERGE_ARM)];
DEFINE βMOVE(S) "[]" = [α(TO_ARM(S,ARMFLAG))];
DEFINE βHERE(S) "[]" = [βBLOCK(α(ARM_POSITION(NULL));
ARRBLT(S,ARM_LINK[6,1,1],16))];
DEFINE βCHANGE(V,D,T)
"[]" = [βBLOCK(α(CHANGE_ARM(V,D,V,0,T,ARMFLAG)))];
DEFINE βFREE "[]" = [ARRBLT(FREE_ARM[0,1],LIMP_ARM[0,1],42);
βMERGE;
βCHANGE(DOWN,0,3000)];
! INITIALIZATION PROCEDURE: TELLS UPPER SEGMENT "I AM NODES" AND WAITS
FOR HANDY TO GET STARTED;
PROCEDURE STARTUP;
BEGIN
OUTSTR(CRLF&"NODES");
PUT_DATA(0,0,"NODES");
WHILE ¬YES_HAND DO CALL(1,"SLEEP");
OUTSTR(" EXECUTION STARTS ..."&CRLF);
END;
REQUIRE STARTUP INITIALIZATION;
! INITIAL VALUE FOR ARRAYS;
PRELOAD_WITH 6,0,0,0,0,0,
1,0,0,0,0,0,
0,1,0,0,0,0,
0,0,1,0,0,0,
0,0,0,1,0,0,
0,0,0,0,1,0,
0,0,0,0,0,1;
REAL ARRAY LIMP_ARM[0:6,1:6];
PRELOAD_WITH 0,0,-1,1; REAL ARRAY DOWN[1:4];
ENDC
! Procedures to handle blue arm;
IFCR BVERS THENC
IFCR PJ THENC
REQUIRE "MOTION" SOURCE_FILE;
ELSEC
REQUIRE "TLKEF5[PNT,RHT]" LOAD_MODULE;
EXTERNAL INTEGER PROCEDURE TLKEF5(REAL ARRAY TNS,ANGLES);
! fills TNS with transpose(<arm trans>), ANGLES with
joint angles (ANGLES[7]=hand) in degrees & inches.
Returns 0 if all ok, otherwise returns 1.
;
PROCEDURE READ_BLUE(REAL ARRAY A);
BEGIN
INTEGER I,J;
OWN REAL ARRAY BESTNS[1:4,1:4], BESANGLES[1:7];
IF TLKEF5(BESTNS,BESANGLES) THEN
ABORT("ERROR IN READING ARM");
ARRCLR(A);
FOR I←1 STEP 1 UNTIL 3 DO
FOR J←1 STEP 1 UNTIL 4 DO
A[I,J]←BESTNS[J,I];
A[4,4]←1.0;
END;
ENDC
ENDC
! cursor & arithmetic stack definition;
RCLASS STACK(STRING ID;INTEGER PDP,TOP,REGISTER;RANY ARRAY A);
! ID is simply the print name of the stack.
stack management subroutines. PDP is the index of the
top element in A. A[0:TOP] is array used to
hold the stack. REGISTER is the ADDRESS of a variable
which always holds the top element of the stack.
;
PROCEDURE MAKESTK(STRING ID;INTEGER TOP;REFERENCE RANY REGISTER,STKID);
BEGIN
RANY ARRAY A[0:TOP];
STKID←NEW_RECORD(STACK);
STACK:ID[STKID]←ID;
STACK:PDP[STKID]←-1;
REGISTER←NULL_RECORD;
STACK:TOP[STKID]←TOP;
STACK:REGISTER[STKID]←LOCATION(REGISTER);
MEMORY[LOCATION(STACK:A[STKID])]↔MEMORY[LOCATION(A)];
END;
DEFINE DCLSTK(ID,KIND,TOP,PNID,SID) "[]" =
[ ASSIGNC SID = "$"&CVPS(ID);
RPTR(STACK) SID;
RPTR(KIND) ID;
INITIALIZE(MAKESTK(PNID,TOP,ID,SID))];
! cursor stacks;
DCLSTK(CURNODE,NODE,4,"N:"); ! general working register;
DCLSTK(CURDAD,NODE,4,"D:"); ! where subparts are to be affixed;
DCLSTK(CURPATH,NODE,4,"P:"); ! current name recognition subtree;
DCLSTK(CURREF,NODE,4,"R:"); ! current reference frame for motion;
DCLSTK(CURMOVE,NODE,4,"M:"); ! current motion frame;
DCLSTK(CURTREE,NODE,4,"T:"); ! current base node for display of tree;
DCLSTK(CURKILL,NODE,4,"K:"); ! magical kill stack;
IFCR HAIRY_VERSION THENC
DCLSTK(CURPLACE,NODE,4,"PL:"); ! current place in a motion sequence;
DCLSTK(CURSTMNT,NODE,4,"ST:"); ! current statement working on;
DCLSTK(CURPROG,NODE,4,"PR:"); ! current program working on;
DEFINE CURSORS "[]"=
[$CURNODE,$CURDAD,$CURPATH,$CURREF,$CURMOVE,$CURKILL,$CURTREE,
$CURPLACE,$CURSTMNT];
ELSEC
DEFINE CURSORS "[]"=
[$CURNODE,$CURDAD,$CURPATH,$CURREF,$CURMOVE,$CURKILL,$CURTREE];
ENDC
RPTR(STACK) LASTCURSOR; ! last cursor operated on;
DEFINE OPND "[]" = [XFELT,VECTOR,SCALAR];
! arithmetic stacks;
DCLSTK(ASTACK,OPND,100,"A:"); ! operand stack;
DCLSTK(BSTACK,OPND,100,"B:"); ! operand stack;
DCLSTK(OSTACK,OPND,100,"O:"); ! "oops" stack;
DEFINE ARITHS "[]" = [ $ASTACK,$BSTACK,$OSTACK ];
RPTR(STACK) LASTARITH; ! last arithmetic stack operated on;
RPTR(STACK) LASTSTACK; ! last stack operated on;
FORWARD SIMPLE STRING PROCEDURE CVGX(REAL X);
FORWARD STRING PROCEDURE OPNDSTR(RPTR(OPND) OP1);
! stack operations;
RPTR(ANY_CLASS) PROCEDURE STACKTOP(RPTR(STACK) STK);
IF STACK:PDP[STK]<0 THEN
RETURN(NULL_RECORD)
ELSE
RETURN(STACK:A[STK][STACK:PDP[STK]]);
RPTR(ANY_CLASS) PROCEDURE PUSHSTK(RPTR(STACK) STK;RPTR(ANY_CLASS) VAL);
BEGIN
STACK:PDP[STK]←STACK:PDP[STK]+1;
IF STACK:PDP[STK]>STACK:TOP[STK] THEN
BEGIN
INTEGER I;
! The stack is bloated, drop bottom element.
( *** ARRBLT would work faster, but this is easier to read ***)
;
FOR I←1 STEP 1 UNTIL STACK:TOP[STK] DO
STACK:A[STK][I-1]←STACK:A[STK][I];
STACK:PDP[STK]←STACK:TOP[STK];
END;
STACK:A[STK][STACK:PDP[STK]]←VAL;
MEMORY[STACK:REGISTER[STK]]←MEMORY[LOCATION(VAL)];
LASTSTACK←STK;
RETURN(VAL);
END;
RPTR(ANY_CLASS) PROCEDURE POPSTK(RPTR(STACK) STK);
BEGIN
LASTSTACK←STK;
IF STACK:PDP[STK]<0 THEN
RETURN(NULL_RECORD)
ELSE
BEGIN
IF (STACK:PDP[STK]←STACK:PDP[STK]-1)≥0 THEN
MEMORY[STACK:REGISTER[STK]]←
MEMORY[LOCATION(STACK:A[STK][STACK:PDP[STK]])]
ELSE
MEMORY[STACK:REGISTER[STK]]←0; ! same as null_record;
RETURN(STACK:A[STK][STACK:PDP[STK]+1]);
END;
END;
RPTR(ANY_CLASS) PROCEDURE SETTOP(RPTR(STACK) STK;RPTR(ANY_CLASS) VAL);
BEGIN
POPSTK(STK);
RETURN(PUSHSTK(STK,VAL));
END;
PROCEDURE EXCHSTK(RPTR(STACK) STK);
BEGIN
RPTR(ANY_CLASS) E1,E2;
IF STACK:PDP[STK]<1 THEN RETURN;
E1←POPSTK(STK);
E2←POPSTK(STK);
PUSHSTK(STK,E1);
PUSHSTK(STK,E2);
END;
RPTR(ANY_CLASS) PROCEDURE ROLLUPSTK(RPTR(STACK) STK);
BEGIN
INTEGER I;
RPTR(ANY_CLASS) V;
IF STACK:PDP[STK]>0 THEN
BEGIN
V←POPSTK(STK);
STACK:PDP[STK]←STACK:PDP[STK]+1;
FOR I←STACK:PDP[STK] STEP -1 UNTIL 1 DO
STACK:A[STK][I]←STACK:A[STK][I-1];
STACK:A[STK][0]←V;
END;
RETURN(STACKTOP(STK));
END;
RPTR(ANY_CLASS) PROCEDURE ROLLDOWNSTK(RPTR(STACK) STK);
BEGIN
INTEGER I;
RPTR(ANY_CLASS) V;
IF STACK:PDP[STK]>0 THEN
BEGIN
V←STACK:A[STK][0];
STACK:PDP[STK]←STACK:PDP[STK]-1;
FOR I←0 STEP 1 UNTIL STACK:PDP[STK] DO
STACK:A[STK][I]←STACK:A[STK][I+1];
PUSHSTK(STK,V);
END;
RETURN(STACKTOP(STK));
END;
! symbol table routines;
RCLASS SMBL(STRING KEY;RPTR(RLIST) HITS;RANY NXT);
DEFINE HTMSK = "'377";
RPTR(RLIST) ARRAY SMBTBL[0:HTMSK];
SIMPLE PROCEDURE INITBL;
BEGIN
INTEGER I;
FOR I←0 STEP 1 UNTIL HTMSK DO
SMBTBL[I]←NEW_RECORD(RLIST);
END;
REQUIRE INITBL INITIALIZATION [0];
SIMPLE INTEGER PROCEDURE HASH36(STRING S);
BEGIN
! returns a 36-bit hashed value of S. Method somewhat follows
Knuth, ch. 6.4, with constant stolen from MJC.
;
DEFINE CNST = "'513527452157";
INTEGER H,L;
L←LENGTH(S);H←0;
WHILE TRUE DO
BEGIN
H ← (H XOR CVSIX(S));
START_CODE ! puts high order digits of H*CNST into H;
MOVE 1,H;
MUL 1,[CNST];
MOVEM 1,H;
END;
L←L-6;
IF L>0 THEN
S←S[7 TO ∞]
ELSE
RETURN(H);
END;
END;
RPTR(SMBL) SMB; ! for use by symbol table routines only;
INTEGER SMBINX;
BOOLEAN PROCEDURE SMBSCH(STRING KEY);
BEGIN
OWN RPTR(CELL) CC;
SMBINX←HASH36(KEY) LAND HTMSK;
CC←RLIST:FIRST[SMBTBL[SMBINX]];
WHILE CC≠NULL_RECORD DO
BEGIN
SMB←LLOP(CC);
IF EQU(SMBL:KEY[SMB],KEY) THEN
BEGIN
CC←NULL_RECORD;
RETURN(TRUE);
END;
END;
RETURN(FALSE);
END;
PROCEDURE ENSYM(STRING KEY;RANY VAL);
BEGIN
IF ¬SMBSCH(KEY) THEN
BEGIN
SMB←NEW_RECORD(SMBL);
SMBL:KEY[SMB]←KEY;
SMBL:HITS[SMB]←NEW_RECORD(RLIST);
RLADD(SMBTBL[SMBINX],SMB,0);
END;
IF RLINX(SMBL:HITS[SMB],VAL)=0 THEN
RLADD(SMBL:HITS[SMB],VAL,0);
END;
PROCEDURE DELSYM(STRING KEY;RANY VAL);
BEGIN
IF SMBSCH(KEY) THEN
BEGIN
RLREM(SMBL:HITS[SMB],VAL,999);
IF RLIST:LEN[SMBL:HITS[SMB]]=NULL_RECORD THEN
RLREM(SMBTBL[SMBINX],SMB,1);
END;
END;
! abort;
ITEMVAR ESCAPE; ! holds a procedure item to be applied by ABORT;
REQUIRE 10 NEW_ITEMS;
EXTERNAL PROCEDURE BAIL;
BOOLEAN BAITRP; ! if set, then BAIL will be called by ABORT;
PROCEDURE ABORT(STRING S("On fourth down, kick!"));
BEGIN
! This is the only really "wizardly" function used
in these routines. Essentially, it prints the
error message, and then calls (via APPLY) the
function in ESCAPE. Typically, this function
will be something that takes you back to a top
level.
If BAITRP is set, then BAIL will be called before
the call to ESCAPE.
;
OUTSTR(" *** "&S&" *** "&CRLF);
IF BAITRP THEN BAIL;
IF ESCAPE=ANY THEN
USERERR(1,1," ESCAPE UNITIALIZED. ABORT IS CONFUSED ")
ELSE
APPLY(∂(ESCAPE));
END;
! new_node, unlnk_node, is_ancestor, lnk_node, eldest_son;
IFCR HAIRY_VERSION THENC
FORWARD RPTR(NODE) PROCEDURE NEW_NODE(STRING PN;
INTEGER KIND(0);
RPTR(ANY_CLASS) INFO(NULL_RECORD));
ELSEC
RPTR(NODE) PROCEDURE NEW_NODE(STRING PN);
BEGIN
REAL ARRAY A[1:5,1:4];
RPTR(NODE) ND;
ND←NEW_RECORD(NODE);
NODE:PNAME[ND]←PN;
A[1,1]←A[2,2]←A[3,3]←A[4,4]←1.0;
MEMORY[LOCATION(A)]↔MEMORY[LOCATION(NODE:XF[ND])];
ENSYM(PN,ND);
RETURN(ND);
END;
ENDC
PROCEDURE UNLNK_NODE(RPTR(NODE) N);
BEGIN
! breaks graph links for node N;
RPTR(NODE) Y,E;
E←NODE:EBRO[N];
IF (Y←NODE:YBRO[N])=NULL_RECORD THEN
BEGIN
IF NODE:DAD[N]≠NULL_RECORD THEN
NODE:SON[NODE:DAD[N]]←E;
END
ELSE
NODE:EBRO[Y]←E;
IF E≠NULL_RECORD THEN
NODE:YBRO[E]←Y;
NODE:EBRO[N]←NULL_RECORD;
NODE:YBRO[N]←NULL_RECORD;
NODE:DAD[N]←NULL_RECORD;
END;
BOOLEAN PROCEDURE IS_ANCESTOR(RPTR(NODE) N,D);
BEGIN
WHILE N≠NULL_RECORD DO
IF N=D THEN
RETURN(TRUE)
ELSE
N←NODE:DAD[N];
RETURN(FALSE);
END;
PROCEDURE LNK_NODE(RPTR(NODE) N,D);
BEGIN
! sets up pointer structure for N to be a child of D;
IF IS_ANCESTOR(D,N) THEN
ABORT(" BACKWARDS AFFIXMENT");
IF NODE:DAD[N]≠NULL_RECORD THEN
UNLNK_NODE(N);
IF (NODE:EBRO[N]←NODE:SON[D])≠NULL_RECORD THEN
NODE:YBRO[NODE:EBRO[N]]←N;
NODE:YBRO[N]←NULL_RECORD;
NODE:DAD[N]←D;
NODE:SON[D]←N;
END;
RPTR(NODE) PROCEDURE ELDEST_SON(RPTR(NODE) N);
BEGIN
RPTR(NODE) ND;
IF N=NULL_RECORD THEN
ABORT(" ELDEST_SON(NULL_RECORD) ?? ");
ND←NODE:SON[N];
IF ND≠NULL_RECORD THEN
WHILE NODE:EBRO[ND]≠NULL_RECORD DO
ND←NODE:EBRO[ND];
RETURN(ND);
END;
PROCEDURE LNK_AFTER(RPTR(NODE) N1,N2);
BEGIN
! inserts N2 as YBRO[N1];
IF NODE:DAD[N2]≠NULL_RECORD THEN
UNLNK_NODE(N2);
IF (NODE:YBRO[N2]←NODE:YBRO[N1])≠NULL_RECORD THEN
NODE:EBRO[NODE:YBRO[N2]]←N2
ELSE
NODE:SON[NODE:DAD[N1]]←N2;
NODE:YBRO[N1]←N2;
NODE:EBRO[N2]←N1;
NODE:DAD[N2]←NODE:DAD[N1];
END;
! copy_tree, controlled_by;
RPTR(NODE) RECURSIVE PROCEDURE COPY_TREE(RPTR(NODE) ND);
BEGIN
! copies the structure rooted at ND. Leaves copy (NND)
affixed to DAD[ND];
RPTR(NODE) NND;
RPTR(NODE) KIDS;
NND←NEW_NODE(NODE:PNAME[ND]);
! sets son, brothers, dad to null_record;
ARRTRAN(NODE:XF[NND],NODE:XF[ND]);
NODE:HOWLINKED[NND]←NODE:HOWLINKED[ND];
KIDS←NODE:SON[ND];
WHILE KIDS≠NULL_RECORD DO
BEGIN
LNK_NODE(COPY_TREE(KIDS),NND);
KIDS←NODE:EBRO[KIDS];
END;
LNK_NODE(NND,WORLD);
RETURN(NND);
END;
BOOLEAN PROCEDURE CONTROLLED_BY(RPTR(NODE) N,D);
BEGIN
! **** The Mikado syndrome strikes again. I know how to
do this but am too lazy to code it up;
RETURN(TRUE);
END;
! purge_id, fix_id;
RECURSIVE PROCEDURE PURGE_ID(RPTR(NODE) ND);
BEGIN
! removes all nodes in the subtree rooted at ND
from the symbol table;
DELSYM(NODE:PNAME[ND],ND);
ND←NODE:SON[ND];
WHILE ND≠NULL_RECORD DO
BEGIN
PURGE_ID(ND);
ND←NODE:EBRO[ND];
END;
END;
RECURSIVE PROCEDURE FIX_ID(RPTR(NODE) ND);
BEGIN
! adds all nodes in the subtree rooted at ND
to the symbol table;
DELSYM(NODE:PNAME[ND],ND);
ND←NODE:SON[ND];
WHILE ND≠NULL_RECORD DO
BEGIN
FIX_ID(ND);
ND←NODE:EBRO[ND];
END;
END;
! some arithmetic on transform matrices;
! Eventually, may want to make these cleverer;
PROCEDURE XFXFMUL(REAL ARRAY A,B,C);
BEGIN
! C ← A*B;
INTEGER I,J,K;
ARRCLR(C);
FOR I←1 STEP 1 UNTIL 3 DO
FOR J←1 STEP 1 UNTIL 4 DO
BEGIN
FOR K←1 STEP 1 UNTIL 4 DO C[I,J]←C[I,J]+A[I,K]*B[K,J];
END;
C[4,4]←1.0;
C[5,4]←0; ! angles are not valid;
END;
PROCEDURE XFINVRT(REAL ARRAY A,B);
BEGIN
! B ← inv(A);
INTEGER I,J;
ARRCLR(B);
FOR I←1 STEP 1 UNTIL 3 DO
FOR J ← 1 STEP 1 UNTIL 3 DO
BEGIN
B[I,J]←A[J,I];
B[I,4]←B[I,4]-B[I,J]*A[J,4];
END;
B[4,4]←1.0;
B[5,4]←0;
END;
PROCEDURE INVXFXF(REAL ARRAY A,B,C);
BEGIN
! C ← inv(A)*B;
OWN REAL ARRAY XFTMP[1:5,1:4];
XFINVRT(A,XFTMP);
XFXFMUL(XFTMP,B,C);
END;
PROCEDURE IABAMUL(REAL ARRAY A,B,C);
BEGIN
! C ← inv(A)*B*A ;
OWN REAL ARRAY XFTMP[1:5,1:4];
INVXFXF(A,B,XFTMP);
XFXFMUL(XFTMP,A,C);
END;
PROCEDURE ABIAMUL(REAL ARRAY A,B,C);
BEGIN
! C ← A*B*inv(A) ;
OWN REAL ARRAY AITMP,TMP[1:5,1:4];
XFINVRT(A,AITMP);
XFXFMUL(B,AITMP,TMP);
XFXFMUL(A,TMP,C);
END;
PROCEDURE SET_ROTATION(REAL ARRAY XF;REAL W,PH,TH);
BEGIN
! fills in the rotation part of XF to correspond to
ROT(Z,TH)*ROT(Y,PH)*ROT(Z,W)
;
REAL SW,CW,SPH,CPH,ST,CT;
SW←SIND(W);CW←COSD(W);
SPH←SIND(PH);CPH←COSD(PH);
ST←SIND(TH);CT←COSD(TH);
XF[1,1]←CW*CPH*CT-SW*ST;XF[1,2]←-CW*ST-SW*CPH*CT;XF[1,3]←SPH*CT;
XF[2,1]←CW*CPH*ST+SW*CT;XF[2,2]←CW*CT-SW*CPH*ST;XF[2,3]←SPH*ST;
XF[3,1]←-CW*SPH;XF[3,2]←SW*SPH;XF[3,3]←CPH;
XF[5,1]←W;XF[5,2]←PH;XF[5,3]←TH;
XF[5,4]←1.0;
END;
PROCEDURE DECODE_ROTATION(REAL ARRAY XF;REFERENCE REAL W,PH,TH);
BEGIN
IF XF[5,4]>0 THEN
BEGIN
W←XF[5,1];PH←XF[5,2];TH←XF[5,3];
END
ELSE
BEGIN
REAL SPH;
PH←ACOS(XF[3,3]);
SPH←SIND(PH);
IF ABS(SPH)<TINY THEN
BEGIN
PH←IF XF[3,3]>0 THEN 0 ELSE π;
TH←0;
W←ATAN2(XF[2,1],XF[2,2]);
SET_ROTATION(XF,W,PH,TH);
END
ELSE
BEGIN
W←ATAN2(XF[3,2],-XF[3,1]);
TH←ATAN2(XF[2,3],XF[1,3]);
XF[5,1]←W;XF[5,2]←PH;XF[5,3]←TH;
XF[5,4]←1.0;
END;
END;
W←W/DEG; PH←PH/DEG; TH←TH/DEG;
END;
! some arithmetic on vectors;
RPTR(VECTOR) PROCEDURE NEW_VECTOR(REAL X,Y,Z);
BEGIN
RPTR(VECTOR) V;
V←NEW_RECORD(VECTOR);
VECTOR:X[V]←X;
VECTOR:Y[V]←Y;
VECTOR:Z[V]←Z;
RETURN(V);
END;
REAL PROCEDURE VDOT(RPTR(VECTOR) V1,V2);
RETURN(VECTOR:X[V1]*VECTOR:X[V2]
+VECTOR:Y[V1]*VECTOR:Y[V2]
+VECTOR:Z[V1]*VECTOR:Z[V2]);
REAL PROCEDURE VMAGN(RPTR(VECTOR) V);
RETURN(SQRT(VECTOR:X[V]↑2+VECTOR:Y[V]↑2+VECTOR:Z[V]↑2));
RPTR(VECTOR) PROCEDURE VDIF(RPTR(VECTOR) V1,V2);
RETURN(NEW_VECTOR(VECTOR:X[V1]-VECTOR:X[V2],
VECTOR:Y[V1]-VECTOR:Y[V2],
VECTOR:Z[V1]-VECTOR:Z[V2]));
RPTR(VECTOR) PROCEDURE NORM(RPTR(VECTOR) V);
BEGIN
REAL M;
M←VMAGN(V);
IF M≤TINY THEN
ABORT(" NORM(NIL) NOT WELL DEFINED ");
RETURN(NEW_VECTOR(VECTOR:X[V]/M,VECTOR:Y[V]/M,VECTOR:Z[V]/M));
END;
RPTR(VECTOR) PROCEDURE VCROSS(RPTR(VECTOR) V1,V2);
RETURN(NEW_VECTOR(VECTOR:Y[V1]*VECTOR:Z[V2]-VECTOR:Z[V1]*VECTOR:Y[V2],
VECTOR:Z[V1]*VECTOR:X[V2]-VECTOR:X[V1]*VECTOR:Z[V2],
VECTOR:X[V1]*VECTOR:Y[V2]-VECTOR:Y[V1]*VECTOR:X[V2]));
RPTR(XFELT) PROCEDURE VVVTRANS(RPTR(VECTOR) A,B,C);
BEGIN
! constructs the trans with origin at A, z-axis thru B, xz plane thru C.;
RPTR(VECTOR) BX,BY,BZ; ! basis vectors;
RPTR(XFELT) XFE;
PRELOAD_WITH [20] 0;
OWN REAL ARRAY XF[1:5,1:4];
XFE←NEW_XFELT;
BZ←NORM(VDIF(B,A));
BX←NORM(VDIF(C,A));
BY←NORM(VCROSS(BZ,BX));
BX←VCROSS(BY,BZ);
XF[1,1]←VECTOR:X[BX];XF[2,1]←VECTOR:Y[BX];XF[3,1]←VECTOR:Z[BX];
XF[1,2]←VECTOR:X[BY];XF[2,2]←VECTOR:Y[BY];XF[3,2]←VECTOR:Z[BY];
XF[1,3]←VECTOR:X[BZ];XF[2,3]←VECTOR:Y[BZ];XF[3,3]←VECTOR:Z[BZ];
XF[1,4]←VECTOR:X[A];XF[2,4]←VECTOR:Y[A];XF[3,4]←VECTOR:Z[A];
XF[4,4]←1.0;
ARRTRAN(XFELT:XF[XFE],XF);
RETURN(XFE);
END;
RPTR(VECTOR) PROCEDURE POSVECT(RPTR(XFELT) XFE);
RETURN(NEW_VECTOR(XFELT:XF[XFE][1,4],
XFELT:XF[XFE][2,4],
XFELT:XF[XFE][3,4]));
RPTR(VECTOR) PROCEDURE XFVECT(REAL ARRAY XF;RPTR(VECTOR) V);
BEGIN
OWN REAL ARRAY VV,XFV[1:4];
INTEGER I,J;
ARRCLR(XFV);
ARRBLT(VV[1],VECTOR:X[V],3);VV[4]←1.0;
FOR I←1 STEP 1 UNTIL 3 DO
FOR J←1 STEP 1 UNTIL 4 DO
XFV[I]←XFV[I]+XF[I,J]*VV[J];
RETURN(NEW_VECTOR(XFV[1],XFV[2],XFV[3]));
END;
RPTR(VECTOR) UXVECT,UYVECT,UZVECT,ZEROVECT;
PROCEDURE INIVECTS;
BEGIN
UXVECT←NEW_VECTOR(1,0,0);
UYVECT←NEW_VECTOR(0,1,0);
UZVECT←NEW_VECTOR(0,0,1);
ZEROVECT←NEW_VECTOR(0,0,0);
END;
REQUIRE INIVECTS INITIALIZATION;
REAL PROCEDURE VANGLE(RPTR(VECTOR) V1,V2);
RETURN(ATAN2(VMAGN(VCROSS(V1,V2)),SQRT(VDOT(V1,V2))));
REAL PROCEDURE ANGLETURNS(REAL ARRAY XF;RPTR(VECTOR) V);
BEGIN
OWN REAL ARRAY RXF[1:5,1:4];
ARRTRAN(RXF,XF);RXF[1,4]←RXF[2,4]←RXF[3,4]←0;
RETURN(VANGLE(XFVECT(RXF,V),V));
END;
! arithmetic ops: tr,apush,apop,atop,tmul,tinv,tedit,oops;
PROCEDURE OPNDCHK(RPTR(OPND) OP;INTEGER OPK);
IF RECTYPE(OP)≠OPK THEN
ABORT(" WRONG OPERAND TYPE");
RPTR(XFELT) PROCEDURE NEW_XFELT;
BEGIN
REAL ARRAY XF[1:5,1:4];
RPTR(XFELT) X;
INTEGER I;
FOR I←1 STEP 1 UNTIL 4 DO XF[I,I]←1.0;
XF[5,4]←1.0;
X←NEW_RECORD(XFELT);
MEMORY[LOCATION(XFELT:XF[X])]↔MEMORY[LOCATION(XF)];
RETURN(X);
END;
RPTR(XFELT) PROCEDURE TR(REAL W,PH,TH,X,Y,Z);
BEGIN
RPTR(XFELT) XFE;
XFE←NEW_XFELT;
SET_ROTATION(XFELT:XF[XFE],W,PH,TH);
XFELT:XF[XFE][1,4]←X;
XFELT:XF[XFE][2,4]←Y;
XFELT:XF[XFE][3,4]←Z;
RETURN(XFE);
END;
RPTR(STACK) PROCEDURE NAMEDASTK(STRING S);
BEGIN
RPTR(STACK) STK;
FOR STK←ARITHS DO
IF EQU(STACK:ID[STK],S) THEN RETURN(STK);
ABORT(S&" IS NOT AN ARITHMETIC STACK");
END;
RPTR(OPND) PROCEDURE APUSH(RPTR(OPND) VAL;STRING STKID(NULL));
BEGIN
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
PUSHSTK(LASTARITH,VAL);
UPDATE;
RETURN(VAL);
END;
RPTR(OPND) PROCEDURE APOP(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←POPSTK(LASTARITH);
IF LASTARITH≠$OSTACK THEN
PUSHSTK($OSTACK,VAL);
UPDATE;
RETURN(VAL);
END;
RPTR(OPND) PROCEDURE AFLUSH(STRING STKID(NULL));
BEGIN
! like APOP except doesn't save anything on OSTACK;
RPTR(OPND) VAL;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←POPSTK(LASTARITH);
UPDATE;
RETURN(VAL);
END;
RPTR(OPND) PROCEDURE ATOP(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←STACKTOP(LASTARITH);
UPDATE;
RETURN(VAL);
END;
PROCEDURE AEXCH(STRING STKID(NULL));
BEGIN
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
EXCHSTK(LASTARITH);
END;
PROCEDURE TMUL(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL,OP1,OP2;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←NEW_XFELT;
OP2←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP2);
OPNDCHK(OP2,LOCATION(XFELT));
OP1←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP1);
OPNDCHK(OP1,LOCATION(XFELT));
XFXFMUL(XFELT:XF[OP1],XFELT:XF[OP2],XFELT:XF[VAL]);
PUSHSTK(LASTARITH,VAL);
UPDATE;
END;
PROCEDURE TINV(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL,OP1;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←NEW_XFELT;
OP1←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP1);
OPNDCHK(OP1,LOCATION(XFELT));
XFINVRT(XFELT:XF[OP1],XFELT:XF[VAL]);
PUSHSTK(LASTARITH,VAL);
UPDATE;
END;
PROCEDURE TEDIT(STRING STKID(NULL));
BEGIN
RPTR(OPND) OP1;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
OP1←POPSTK(LASTARITH);
UPDATE;
SETFORMAT(0,7);
LODED("APUSH("&OPNDSTR(OP1)&","""&STACK:ID[LASTARITH]&""");"&CR);
SETFORMAT(0,3);
END;
PROCEDURE OOPS(STRING STKID(NULL));
BEGIN
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
PUSHSTK(LASTARITH,POPSTK($OSTACK));
UPDATE;
END;
RPTR(OPND) PROCEDURE AROLLUP(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←ROLLUPSTK(LASTARITH);
UPDATE;
RETURN(VAL);
END;
RPTR(OPND) PROCEDURE AROLLDOWN(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←ROLLDOWNSTK(LASTARITH);
UPDATE;
RETURN(VAL);
END;
! absxf, setabsxf, absxfe;
PROCEDURE ABSXF(RPTR(NODE) N;REAL ARRAY XF);
BEGIN
! sets up xf to be the location of N wrt WORLD;
ARRTRAN(XF,NODE:XF[N]); ! xf ← node:xf[n];
WHILE NODE:HOWLINKED[N]≠INDLNK DO
BEGIN
OWN REAL ARRAY XFTMP[1:5,1:4];
N←NODE:DAD[N];
IF N=NULL_RECORD THEN
BEGIN
BUG("FUNNY TREE STRUCTURE");
RETURN;
END;
XFXFMUL(NODE:XF[N],XF,XFTMP); ! xftmp ← xf[n]*xf;
ARRTRAN(XF,XFTMP); ! xf ← xftmp;
END;
END;
RPTR(XFELT) PROCEDURE ABSXFE(RPTR(NODE) ND);
BEGIN
RPTR(XFELT) XFE;
XFE←NEW_XFELT;
ABSXF(ND,XFELT:XF[XFE]);
RETURN(XFE);
END;
PROCEDURE SETABSXF(RPTR(NODE) N;REAL ARRAY XF);
BEGIN
! sets up link transforms so that ABSXF(N)=XF.
(If rigid affixments, will move parents)
;
OWN REAL ARRAY XFTMP,XFTMP2,XFTMP3[1:5,1:4];
ARRTRAN(XFTMP,XF);
WHILE NODE:HOWLINKED[N]=RGDLNK DO
BEGIN
XFINVRT(NODE:XF[N],XFTMP3);
XFXFMUL(XFTMP,XFTMP3,XFTMP2);
ARRTRAN(XFTMP,XFTMP2); ! xftmp ← xftmp*inv(xf[n]) ;
N←NODE:DAD[N];
END;
IF NODE:HOWLINKED[N]=INDLNK THEN
ARRTRAN(NODE:XF[N],XFTMP)
ELSE
BEGIN
ABSXF(NODE:DAD[N],XFTMP2);
INVXFXF(XFTMP2,XFTMP,NODE:XF[N]);
END;
END;
! afx_node;
PROCEDURE AFX_NODE(RPTR(NODE) N,D;INTEGER HOW);
BEGIN
! affixes N to D in the manner described by HOW;
! *** all this can be made more efficient. ***;
OWN REAL ARRAY XFTMP1,XFTMP2[1:5,1:4];
IF HOW = INDLNK THEN
ABSXF(N,NODE:XF[N]) ! xf[n]← absxf(N);
ELSE
BEGIN
ABSXF(D,XFTMP2);
XFINVRT(XFTMP2,XFTMP1);
ABSXF(N,XFTMP2);
XFXFMUL(XFTMP1,XFTMP2,NODE:XF[N]); ! xf[n]←inv(absxf(D))*absxf(n);
END;
LNK_NODE(N,D);
NODE:HOWLINKED[N]←HOW;
END;
! node_csr, id_decode, nodespec, λ;
INTEGER DOTBRK;
INITIALIZE(SETBREAK(DOTBRK←GETBREAK,".",NULL,"INS"));
BOOLEAN BAD_ID_GIVES_NULL;INITIALIZE(BAD_ID_GIVES_NULL←FALSE);
RPTR(STACK) PROCEDURE NODE_CSR(STRING ID);
BEGIN
RPTR(STACK) CSR;
FOR CSR ← CURSORS DO
BEGIN
IF EQU(STACK:ID[CSR],ID) THEN
RETURN(CSR);
END;
ABORT(ID&" not a node stack");
END;
RPTR(NODE) PROCEDURE ID_DECODE(STRING ID);
BEGIN
RPTR(NODE) HANDLE,ND,GOODHIT;
RPTR(RLIST) HITLIST;
RPTR(CELL) C;
STRING NID,PID;
INTEGER BRK;
HANDLE←CURPATH;
IF HANDLE=NULL_RECORD THEN HANDLE←WORLD;
PID←ID&".";
WHILE LENGTH(PID) DO
BEGIN "ONE_ID"
NID←SCAN(PID,DOTBRK,BRK);
IF ¬SMBSCH(NID) THEN
IF BAD_ID_GIVES_NULL THEN
RETURN(NULL_RECORD)
ELSE
ABORT(ID&" NOT FOUND");
HITLIST←SMBL:HITS[SMB];
IF RLIST:LEN[HITLIST]=0 THEN
ABORT(ID&" NOT FOUND");
IF RLIST:LEN[HITLIST]=1 THEN
HANDLE←RLNTH(HITLIST,1)
ELSE
BEGIN
C←RLIST:FIRST[HITLIST];
GOODHIT←NULL_RECORD;
WHILE C≠NULL_RECORD DO
BEGIN "CHKHITS"
ND←LLOP(C);
IF IS_ANCESTOR(ND,HANDLE) THEN
BEGIN
IF GOODHIT≠NULL_RECORD THEN
ABORT(ID&" AMBIGUOUS") ! always complain;
ELSE
GOODHIT←ND;
END;
END "CHKHITS";
IF GOODHIT=NULL_RECORD THEN
BEGIN
IF BAD_ID_GIVES_NULL THEN
RETURN(NULL_RECORD)
ELSE
ABORT(ID&" NOT FOUND")
END
ELSE
HANDLE←GOODHIT;
END;
END "ONE_ID";
RETURN(HANDLE);
END;
RPTR(NODE) PROCEDURE NODESPEC(STRING NDSPC);
BEGIN
RPTR(NODE) ND;
IF NDSPC[∞ FOR 1]=":" THEN
ND←STACKTOP(NODE_CSR(NDSPC))
ELSE
ND←ID_DECODE(NDSPC);
IF ND=NULL_RECORD THEN
ABORT(NDSPC&" IS NULL ");
RETURN(ND);
END;
STRING LASTλ;INITIALIZE(LASTλ←"N:");
RPTR(NODE) PROCEDURE λ(STRING NDSPC(NULL));
BEGIN
IF NDSPC=NULL THEN
NDSPC←LASTλ
ELSE
LASTλ←NDSPC;
RETURN(NODESPEC(NDSPC));
END;
! editing ops: mk_node, copy_node, name_node;
BOOLEAN PROCEDURE CCHECK(REFERENCE RPTR(NODE) C;STRING CURSORID);
BEGIN
! returns true if cursor C constains a node.
otherwise aborts;
IF C=NULL_RECORD THEN
BEGIN
ABORT(CURSORID&" not initialized!");
RETURN(FALSE);
END
ELSE
RETURN(TRUE);
END;
PROCEDURE MK_NODE(STRING ID);
BEGIN
PUSHSTK($CURNODE,NEW_NODE(ID));
LNK_NODE(CURNODE,WORLD);
NODE:HOWLINKED[CURNODE]←INDLNK;
LASTCURSOR←$CURNODE;
UPDATE;
END;
PROCEDURE COPY_NODE(STRING NDSPC("N:"));
BEGIN
RPTR(NODE) ND;
IF LENGTH(NDSPC)>0 THEN
ND←NODESPEC(NDSPC)
ELSE
ND←CURNODE;
IF ND=NULL_RECORD THEN ABORT(" COPY WHAT?");
PUSHSTK($CURNODE,COPY_TREE(ND));
AFX_NODE(CURNODE,WORLD,INDLNK);
LASTCURSOR←$CURNODE;
UPDATE;
END;
PROCEDURE NAME_NODE(STRING ID);
BEGIN
IF CCHECK(CURNODE,"N:") THEN
BEGIN
NODE:PNAME[CURNODE]←ID;
LASTCURSOR←$CURNODE;
UPDATE;
END;
END;
! editing ops: affix_node, rigid, nonrigid, independent, merge;
PROCEDURE AFFIX_NODE(INTEGER HOW);
IF CCHECK(CURNODE,"N:")∧CCHECK(CURDAD,"D:") THEN
BEGIN
AFX_NODE(CURNODE,CURDAD,HOW);
LASTCURSOR←$CURNODE;
END;
PROCEDURE RIGID;
BEGIN
AFFIX_NODE(RGDLNK);
UPDATE;
END;
PROCEDURE NONRIGID;
BEGIN
AFFIX_NODE(NRGLNK);
UPDATE;
END;
PROCEDURE INDEPENDENT;
BEGIN
AFFIX_NODE(INDLNK);
UPDATE;
END;
PROCEDURE MERGE;
IF CCHECK(CURNODE,"N:")∧CCHECK(CURDAD,"D:") THEN
BEGIN
IF CURNODE=CURDAD THEN
ABORT("INVALID MERGER");
UPDSUPPRESS←UPDSUPPRESS+1;
WHILE NODE:SON[CURNODE]≠NULL_RECORD DO
AFX_NODE(NODE:SON[CURNODE],CURDAD,
NODE:HOWLINKED[NODE:SON[CURNODE]]);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
! editing ops: kill, unkill;
PROCEDURE KILL(STRING NDSPC("N:"));
BEGIN
RPTR(NODE) D,ND;
RPTR(STACK) CSR;
IF LENGTH(NDSPC)>0 THEN
ND←NODESPEC(NDSPC)
ELSE
ND←STACKTOP($CURNODE);
IF ND=NULL_RECORD THEN ABORT(" KILL WHAT?");
D←NODE:DAD[ND];
UNLNK_NODE(ND);
NODE:DAD[ND]←D;
PUSHSTK($CURKILL,ND);
PURGE_ID(ND);
FOR CSR ← CURSORS DO
BEGIN
IF CSR=$CURKILL THEN CONTINUE;
WHILE IS_ANCESTOR(STACKTOP(CSR),ND) DO
POPSTK(CSR);
END;
LASTCURSOR←$CURNODE;
UPDATE;
END;
PROCEDURE UNKILL;
BEGIN
RPTR(NODE) ND,DD;
ND←POPSTK($CURKILL);
IF ND≠NULL_RECORD THEN
BEGIN
DD←NODE:DAD[ND];
NODE:DAD[ND]←NULL_RECORD;
FIX_ID(ND);
LNK_NODE(ND,DD);
PUSHSTK($CURNODE,ND);
LASTCURSOR←$CURNODE;
END;
UPDATE;
END;
! editing ops: godad,goson,elder,younger;
PROCEDURE GOSON(STRING CID(NULL));
BEGIN
RPTR(NODE) ND;
IF LENGTH(CID)>0 THEN
LASTCURSOR←NODE_CSR(CID);
ND←STACKTOP(LASTCURSOR);
IF ND≠NULL_RECORD THEN
BEGIN
POPSTK(LASTCURSOR);
PUSHSTK(LASTCURSOR,NODE:SON[ND]);
END;
UPDATE;
END;
PROCEDURE GODAD(STRING CID(NULL));
BEGIN
RPTR(NODE) ND;
IF LENGTH(CID)>0 THEN
LASTCURSOR←NODE_CSR(CID);
ND←STACKTOP(LASTCURSOR);
IF ND≠NULL_RECORD THEN
BEGIN
POPSTK(LASTCURSOR);
PUSHSTK(LASTCURSOR,NODE:DAD[ND]);
END;
UPDATE;
END;
PROCEDURE ELDER(STRING CID(NULL));
BEGIN
RPTR(NODE) ND;
IF LENGTH(CID)>0 THEN
LASTCURSOR←NODE_CSR(CID);
ND←STACKTOP(LASTCURSOR);
IF ND≠NULL_RECORD THEN
BEGIN
POPSTK(LASTCURSOR);
PUSHSTK(LASTCURSOR,NODE:EBRO[ND]);
END;
UPDATE;
END;
PROCEDURE YOUNGER(STRING CID(NULL));
BEGIN
RPTR(NODE) ND;
IF LENGTH(CID)>0 THEN
LASTCURSOR←NODE_CSR(CID);
ND←STACKTOP(LASTCURSOR);
IF ND≠NULL_RECORD THEN
BEGIN
POPSTK(LASTCURSOR);
PUSHSTK(LASTCURSOR,NODE:YBRO[ND]);
END;
UPDATE;
END;
! editing ops: cpush, cpop, ctop, cexch, crollup, crolldown;
RPTR(NODE) PROCEDURE CPUSH(RPTR(NODE) VAL;STRING CID(NULL));
BEGIN
IF CID≠NULL THEN LASTCURSOR←NODE_CSR(CID);
PUSHSTK(LASTCURSOR,VAL);
UPDATE;
RETURN(VAL);
END;
RPTR(NODE) PROCEDURE CPOP(STRING CID(NULL));
BEGIN
RPTR(NODE) ND;
IF CID≠NULL THEN LASTCURSOR←NODE_CSR(CID);
ND←POPSTK(LASTCURSOR);
UPDATE;
RETURN(ND);
END;
RPTR(NODE) PROCEDURE CTOP(STRING CID(NULL));
BEGIN
RPTR(NODE) ND;
IF CID≠NULL THEN LASTCURSOR←NODE_CSR(CID);
ND←STACKTOP(LASTCURSOR);
UPDATE;
RETURN(ND);
END;
PROCEDURE CEXCH(STRING CID(NULL));
BEGIN
IF CID≠NULL THEN LASTCURSOR←NODE_CSR(CID);
EXCHSTK(LASTCURSOR);
UPDATE;
END;
RPTR(NODE) PROCEDURE CROLLUP(STRING CID(NULL));
BEGIN
RPTR(NODE) ND;
IF CID≠NULL THEN LASTCURSOR←NODE_CSR(CID);
ND←ROLLUPSTK(LASTCURSOR);
UPDATE;
RETURN(ND);
END;
RPTR(NODE) PROCEDURE CROLLDOWN(STRING CID(NULL));
BEGIN
RPTR(NODE) ND;
IF CID≠NULL THEN LASTCURSOR←NODE_CSR(CID);
ND←ROLLDOWNSTK(LASTCURSOR);
UPDATE;
RETURN(ND);
END;
! editing ops: absloc, relloc, absset, relset;
RPTR(XFELT) PROCEDURE ABSLOC(STRING NDSPC("N:"));
BEGIN
RPTR(NODE) ND;
IF LENGTH(NDSPC)>0 THEN
ND←NODESPEC(NDSPC)
ELSE
ND←STACKTOP($CURNODE);
IF ND=NULL_RECORD THEN ABORT(" LOC OF WHAT?");
RETURN(ABSXFE(ND));
END;
RPTR(XFELT) PROCEDURE RELLOC(STRING NDSPC("N:"));
BEGIN
RPTR(NODE) ND;
RPTR(XFELT) XFE;
IF LENGTH(NDSPC)>0 THEN
ND←NODESPEC(NDSPC)
ELSE
ND←STACKTOP($CURNODE);
IF ND=NULL_RECORD THEN ABORT(" LOC OF WHAT?");
XFE←NEW_XFELT;
ARRTRAN(XFELT:XF[XFE],NODE:XF[ND]);
RETURN(XFE);
END;
PROCEDURE ABSSET(STRING NDSPC("N:"),ASTK(NULL));
BEGIN
RPTR(NODE) ND;
RPTR(XFELT) XFE;
IF LENGTH(NDSPC)>0 THEN
ND←NODESPEC(NDSPC)
ELSE
ND←STACKTOP($CURNODE);
IF ND=NULL_RECORD THEN ABORT(" LOC OF WHAT?");
IF LENGTH(ASTK)>0 THEN
LASTARITH←NAMEDASTK(ASTK);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
XFE←STACKTOP(LASTARITH);
IF RECTYPE(XFE)≠LOCATION(XFELT) THEN
ABORT(" IMPROPER TYPE ");
SETABSXF(ND,XFELT:XF[XFE]);
UPDATE;
END;
PROCEDURE RELSET(STRING NDSPC("N:"),ASTK(NULL));
BEGIN
RPTR(NODE) ND;
RPTR(XFELT) XFE;
IF LENGTH(NDSPC)>0 THEN
ND←NODESPEC(NDSPC)
ELSE
ND←STACKTOP($CURNODE);
IF ND=NULL_RECORD THEN ABORT(" LOC OF WHAT?");
IF LENGTH(ASTK)>0 THEN
LASTARITH←NAMEDASTK(ASTK);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
XFE←STACKTOP(LASTARITH);
IF RECTYPE(XFE)≠LOCATION(XFELT) THEN
ABORT(" IMPROPER TYPE ");
ARRTRAN(NODE:XF[ND],XFELT:XF[XFE]);
UPDATE;
END;
! motion operations;
PROCEDURE READARM;
! This procedure finds out where the arm actually is and then
stores this frame as the absolute frame of the arm in the
subpart hierarchy.;
BEGIN
OWN REAL ARRAY AXF[1:5,1:4];
IFCR YVERS THENC
βHERE(AXF[1,1]); ! AXF is actual arm frame;
ENDC
IFCR BVERS THENC
READ_BLUE(AXF);
ENDC
AXF[5,4]←0;
SETABSXF(ARM,AXF);
UPDATE;
END;
PROCEDURE GOARM(REAL ARRAY BXF);
! This procedure moves the arm to BXF;
BEGIN
IFCR YVERS THENC
OWN REAL ARRAY BXFTEMP[1:4,1:4];
ARRTRAN(BXFTEMP,BXF);
βEXEC(βMOVE(BXFTEMP)); ! move arm to BXF;
READARM;
ENDC
IFCR BVERS THENC
goblue(bxf);
ENDC
END;
PROCEDURE MOVEABS(STRING STKID(NULL));
! Suppose the absolute frame of the arm is AXF
the absolute frame of "motion" is MXF
and we want the new motion frame to be NXF.
We therefore have to compute the new arm frame BXF.
This means MXF = AXF * X where X is the displacement trans between the
arm and the motion frames. So X = inverse(AXF) * MXF. Then NXF = BXF * X
So, BXF = NXF * inverse(X) = NSF * inverse(MXF) * AXF.;
BEGIN
OWN REAL ARRAY MXF[1:5,1:4],
AXF[1:5,1:4],
BXF[1:5,1:4],
TMP[1:5,1:4];
RPTR(OPND) PNXF;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
IF CURMOVE=NULL_RECORD THEN
ABORT(" NO MOTION FRAME DEFINED ");
IF ¬ CONTROLLED_BY(CURMOVE,ARM) THEN
ABORT(" CANNOT CONTROL FRAME "&NODE:PNAME[CURMOVE]);
UPDSUPPRESS←UPDSUPPRESS+1;
READARM; ! get honest value;
ABSXF(ARM,AXF); ! AXF is arm frame;
ABSXF(CURMOVE,MXF); ! MXF is motion frame;
PNXF←STACKTOP(LASTARITH); ! PNXF points to NXF new motion frame;
IF RECTYPE(PNXF)≠LOCATION(XFELT) THEN
ABORT("TOP OF "&STACK:ID[LASTARITH]&" NOT A TRANS.");
INVXFXF(MXF,AXF,TMP); ! TMP = inverse(MXF) * NXF;
XFXFMUL(XFELT:XF[PNXF],TMP,BXF); ! BXF = AXF * inverse(MXF) * NXF;
GOARM(BXF);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
PROCEDURE MOVEREF(STRING STKID(NULL));
! Suppose the absolute frame of "reference" is RXF
and we are given a displacement DXF relative to RXF
such that the new motion frame NXF must be RXF * DXF.
This means NXF = RXF * DXF and then call moveabs as before.;
BEGIN
OWN REAL ARRAY RXF[1:5,1:4];
RPTR(OPND) PNXF;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
IF CURMOVE=NULL_RECORD THEN
ABORT(" NO MOTION FRAME DEFINED ");
IF ¬ CONTROLLED_BY(CURMOVE,ARM) THEN
ABORT(" CANNOT CONTROL FRAME "&NODE:PNAME[CURMOVE]);
UPDSUPPRESS←UPDSUPPRESS+1;
ABSXF(CURREF,RXF); ! RXF is reference frame;
PNXF←STACKTOP(LASTARITH); ! PNXF points to DXF displacement;
IF RECTYPE(PNXF)≠LOCATION(XFELT) THEN
ABORT("TOP OF "&STACK:ID[LASTARITH]&" NOT A TRANS.");
PUSHSTK(LASTARITH,NEW_XFELT); ! push a new temp;
XFXFMUL(RXF,XFELT:XF[PNXF],XFELT:XF[STACKTOP(LASTARITH)]); ! TEMP←RXF*DXF;
MOVEABS(NULL); ! do absolute move as above;
POPSTK(LASTARITH); ! we hope MOVEABS doesn't change
LASTARITH;
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
PROCEDURE MOVEREL(STRING STKID(NULL));
! Suppose the absolute frame of "reference" is RXF
and we are given a displacement DXF relative to RXF
such that the new motion frame NXF must be MXF *inv(RXF)*DXF*RXF.
;
BEGIN
OWN REAL ARRAY RXF,MXF,TMP[1:5,1:4];
RPTR(OPND) PNXF;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
IF CURMOVE=NULL_RECORD THEN
ABORT(" NO MOTION FRAME DEFINED ");
IF ¬ CONTROLLED_BY(CURMOVE,ARM) THEN
ABORT(" CANNOT CONTROL FRAME "&NODE:PNAME[CURMOVE]);
UPDSUPPRESS←UPDSUPPRESS+1;
ABSXF(CURREF,RXF); ! RXF is reference frame;
READARM;
ABSXF(CURMOVE,MXF); ! MXF is motion frame;
PNXF←STACKTOP(LASTARITH); ! PNXF points to DXF displacement;
IF RECTYPE(PNXF)≠LOCATION(XFELT) THEN
ABORT("TOP OF "&STACK:ID[LASTARITH]&" NOT A TRANS.");
PUSHSTK(LASTARITH,NEW_XFELT); ! push a new temp;
ABIAMUL(RXF,XFELT:XF[PNXF],TMP);
XFXFMUL(TMP,MXF,XFELT:XF[STACKTOP(LASTARITH)]);
MOVEABS(NULL); ! do absolute move as above;
POPSTK(LASTARITH); ! we hope MOVEABS doesn't change
LASTARITH;
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
PROCEDURE FREE;
! This frees the arm for 5 seconds, during which time the user
should move the arm to a desired location and push the magic
red button. The absolute frame of the arm is then updated.
If instead there is a time-out without the magic red button
being pushed, nothing happens.;
BEGIN
UPDSUPPRESS←UPDSUPPRESS+1;
IFCR YVERS THENC
βEXEC(βFREE); ! free the arm for 5 seconds;
ENDC
IFCR BVERS THENC
OUTSTR("BLUE VERSION DOESN'T SUPPORT FREE YET");
ENDC
READARM;
UPDSUPPRESS←UPDSUPPRESS-1;
IFCR YVERS THENC
IF ARM_STATUS≠'1000 THEN
ABORT(" TIMEOUT ");
ENDC
UPDATE;
END;
PROCEDURE ATFID;
! This procedure sets the absolute frame of the pointer equal to
that of the fiducial.;
BEGIN
REAL ARRAY FXF[1:5,1:4];
UPDSUPPRESS←UPDSUPPRESS+1;
READARM;
ABSXF(FIDUCIAL,FXF);
SETABSXF(POINTER,FXF);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
! Not included in this code is type checking and oopsing;
PROCEDURE CONSTRUCT(STRING STKID(NULL));
! This constructs an implicit frame from the top three frames
on the last arithmetic stack referenced. The three frames are
popped off, and the new implicit frame is pushed on.;
BEGIN
RPTR(OPND) OP1,OP2,OP3;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
OP3←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP3);
OPNDCHK(OP3,LOCATION(XFELT));
OP2←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP2);
OPNDCHK(OP2,LOCATION(XFELT));
OP1←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP1);
OPNDCHK(OP1,LOCATION(XFELT));
PUSHSTK(LASTARITH,VVVTRANS(POSVECT(OP1),POSVECT(OP2),POSVECT(OP3)));
UPDATE;
END;
PROCEDURE DEFFID;
! This procedure asserts that the fiducial is currently at the ARM frame;
BEGIN
REAL ARRAY FXF[1:5,1:4];
UPDSUPPRESS←UPDSUPPRESS+1;
READARM;
ABSXF(ARM,FXF);
SETABSXF(FIDUCIAL,FXF);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
! macro operations for motion, pointit, grabbit, fdef;
PROCEDURE DMOVE(REAL X,Y,Z);
BEGIN
APUSH(TR(0,0,0,X,Y,Z));
MOVEREL;
AFLUSH;
UPDATE;
END;
PROCEDURE DX(REAL X);
DMOVE(X,0,0);
PROCEDURE DY(REAL Y);
DMOVE(0,Y,0);
PROCEDURE DZ(REAL Z);
DMOVE(0,0,Z);
PROCEDURE POINTIT(STRING STKID(NULL));
BEGIN
READARM;
APUSH(ABSXFE(POINTER),STKID);
END;
PROCEDURE GRABBIT(STRING STKID(NULL));
BEGIN
READARM;
APUSH(ABSXFE(ARM),STKID);
END;
PROCEDURE HERE(STRING ID);
BEGIN
UPDSUPPRESS←UPDSUPPRESS+1;
MK_NODE(ID);
GRABBIT;
ABSSET;
APOP;
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
! altrans,alid, aldecs, unique_id;
BOOLEAN PROCEDURE UNIQUE_ID(RPTR(NODE) ND,HANDLE);
BEGIN
! returns true if NODE:ID[ND] is unique for the
subtree homed at handle minus the subtree
homed at ND;
RPTR(CELL) C;
RPTR(NODE) N;
BOOLEAN HAVEHIT;
IF ¬IS_ANCESTOR(ND,HANDLE) THEN
ABORT(NODE:PNAME[ND]&" not descended from "&NODE:PNAME[HANDLE]);
IF ¬SMBSCH(NODE:PNAME[ND]) THEN
ABORT(NODE:PNAME[ND]&" not in symbol table.");
HAVEHIT←FALSE;
C←RLIST:FIRST[SMBL:HITS[SMB]];
WHILE C≠NULL_RECORD DO
BEGIN
N←LLOP(C);
IF IS_ANCESTOR(N,HANDLE) THEN
BEGIN
IF N=ND ∨ NOT IS_ANCESTOR(N,ND) THEN
BEGIN
IF HAVEHIT THEN RETURN(FALSE);
HAVEHIT←TRUE;
END;
END;
END;
RETURN(HAVEHIT);
END;
STRING RECPROC ALID(RPTR(NODE) ND,HANDLE);
BEGIN
! returns a good unique name for ND in subtree of HANDLE;
IF ND=NULL_RECORD THEN
RETURN("__");
IF UNIQUE_ID(ND,HANDLE) THEN
RETURN(NODE:PNAME[ND])
ELSE
RETURN(ALID(NODE:DAD[ND],HANDLE)&"_"&NODE:PNAME[ND]);
END;
BOOLEAN WTLKLUGE; ! ***** made necessary by lossage of PARSE[AL,WTL].
Remove as soon as feasible. *****;
STRING PROCEDURE ALTF(REAL ARRAY XF;STRING TF);
BEGIN
STRING SIMPLE PROCEDURE CV(REAL R);
IF WTLKLUGE THEN RETURN(CVF(R))
ELSE RETURN(CVGX(R));
STRING SIMPLE PROCEDURE ROTFORM(STRING AXIS;REAL W);
IF WTLKLUGE THEN
RETURN("("&AXIS&" ROT "&CV(W)&")")
ELSE
RETURN("ROT("&AXIS&","&CV(W)&")");
REAL W,PH,TH;
STRING RS,SC;
DECODE_ROTATION(XF,W,PH,TH);
IF WTLKLUGE THEN
SETFORMAT(1,7)
ELSE
SETFORMAT(0,7);
RS←TF&"(";SC←NULL;
IF ABS(TH)>TINY THEN
BEGIN
RS←RS&ROTFORM("ZHAT",TH);
SC←"*";
END;
IF ABS(PH)>TINY THEN
BEGIN
RS←RS&SC&ROTFORM("YHAT",PH);
SC←"*";
END;
IF ABS(W)>TINY THEN
BEGIN
RS←RS&SC&ROTFORM("ZHAT",W);
SC←"*";
END;
IF LENGTH(SC)=0 THEN
RS←RS&"NILROTN";
IF WTLKLUGE THEN
SETFORMAT(1,3)
ELSE
SETFORMAT(0,3);
RETURN(RS&",VECTOR("&CV(XF[1,4])&","&CV(XF[2,4])&","&CV(XF[3,4])
&"))");
END;
STRING PROCEDURE ALTRANS(REAL ARRAY XF);
RETURN(ALTF(XF,"TRANS"));
STRING PROCEDURE ALFRAME(REAL ARRAY XF);
RETURN(ALTF(XF,"FRAME"));
STRING PROCEDURE ALDEC(RPTR(NODE) ND,HANDLE);
BEGIN
STRING AID,DS;
AID←ALID(ND,HANDLE);
DS←"FRAME "&AID&";"&CRLF;
CASE NODE:HOWLINKED[ND] OF
BEGIN
[INDLNK] DS←DS&AID&" ← "&ALFRAME(NODE:XF[ND])&";"&CRLF;
[NRGLNK] DS←DS&"AFFIX "&AID&" TO "&ALID(NODE:DAD[ND],HANDLE)&" AT "
& ALTRANS(NODE:XF[ND])&" NONRIGIDLY;"&CRLF;
[RGDLNK] DS←DS&"AFFIX "&AID&" TO "&ALID(NODE:DAD[ND],HANDLE)&" AT "
& ALTRANS(NODE:XF[ND])&" RIGIDLY;"&CRLF
END;
RETURN(DS&CRLF);
END;
RECURSIVE STRING PROCEDURE AL_SUBTREE(RPTR(NODE) ND,HANDLE);
BEGIN
STRING DS;
RPTR(NODE) SN;
DS←ALDEC(ND,HANDLE);
SN←NODE:SON[ND];
WHILE SN≠NULL_RECORD DO
BEGIN
DS←DS&AL_SUBTREE(SN,HANDLE);
SN←NODE:EBRO[SN];
END;
RETURN(DS);
END;
PROCEDURE AL_OUT(RPTR(NODE) ND,HANDLE);
BEGIN
IF ALCH<0 THEN
BEGIN
OPEN(ALCH←GETCHAN,"DSK",0,0,3,0,0,ALEOF);
ALEOF←-1;
WHILE ALEOF DO
BEGIN
OUTSTR("OUTPUT FILE (NULL TO FORGET IT)=");
ALFID←INCHWL;
IF LENGTH(ALFID)=0 THEN
BEGIN
RELEASE(ALCH);
ALCH←-1;
DONE;
END;
ENTER(ALCH,ALFID,ALEOF);
IF ALEOF THEN OUTSTR("ENTER FAILED"&CRLF);
END;
UPDATE;
END;
CPRINT(ALCH,AL_SUBTREE(ND,HANDLE));
END;
PROCEDURE AL_CLOSE;
BEGIN
IF ALCH>0 THEN
BEGIN
OUTSTR("CLOSING "&ALFID&CRLF);
RELEASE(ALCH);
ALCH←-1;
UPDATE;
END;
END;
CLEANUP AL_CLOSE;
PROCEDURE AL_WRITE;
AL_OUT(CURNODE,CURPATH);
! code to emit a pointy command file;
RPTR(NODE) PROCEDURE OLDEST_SON(RPTR(NODE) ND);
BEGIN
RPTR(NODE) K;
IF ND=NULL_RECORD THEN RETURN(NULL_RECORD);
K←NODE:SON[ND];
IF K=NULL_RECORD THEN RETURN(NULL_RECORD);
WHILE NODE:EBRO[K]≠NULL_RECORD DO
K←NODE:EBRO[K];
RETURN(K);
END;
RECURSIVE PROCEDURE SAVE_NODE(RPTR(NODE) ND);
BEGIN
RPTR(NODE) K;
IF ND=NULL_RECORD THEN RETURN;
IF PCH<0 THEN
BEGIN
OPEN(PCH←GETCHAN,"DSK",0,0,3,0,0,PCEOF);
PCEOF←-1;
WHILE PCEOF DO
BEGIN
OUTSTR("OUTPUT FILE (NULL TO FORGET IT)=");
PCFID←INCHWL;
IF LENGTH(PCFID)=0 THEN
BEGIN
RELEASE(PCH);
PCH←-1;
DONE;
END;
ENTER(PCH,PCFID,PCEOF);
IF PCEOF THEN OUTSTR("ENTER FAILED"&CRLF);
END;
UPDATE;
END;
K←OLDEST_SON(ND);
WHILE K≠NULL_RECORD DO
BEGIN
SAVE_NODE(K);
K←NODE:YBRO[K];
END;
CPRINT(PCH,CRLF&"MK_NODE(""",NODE:PNAME[ND],""");");
SETFORMAT(0,7);
CPRINT(PCH,"APUSH(",OPNDSTR(ABSXFE(ND)),");"&CRLF);
SETFORMAT(0,3);
CPRINT(PCH,"ABSSET;APOP;"&CRLF);
K←NODE:SON[ND];
IF K≠NULL_RECORD THEN
BEGIN
CPRINT(PCH,"CPUSH(CPOP(""N:""),""D:"");"&CRLF);
WHILE K≠NULL_RECORD DO
BEGIN
CPRINT(PCH,"CPUSH(CURNODE,""N:"");");
CPRINT(PCH,"ELDER;CEXCH;");
CASE NODE:HOWLINKED[K] OF
BEGIN
[INDLNK] CPRINT(PCH,"INDEPENDENT;");
[NRGLNK] CPRINT(PCH,"NONRIGID;");
[RGDLNK] CPRINT(PCH,"RIGID;")
END;
CPRINT(PCH,"CPOP;"&CRLF);
K←NODE:EBRO[K];
END;
CPRINT(PCH,"CPOP(""N:"");");
CPRINT(PCH,"CPUSH(CPOP(""D:""),""N:"");"&CRLF);
END;
END;
PROCEDURE P_CLOSE;
BEGIN
IF PCH>0 THEN
BEGIN
OUTSTR("CLOSING "&PCFID&CRLF);
RELEASE(PCH);
PCH←-1;
UPDATE;
END;
END;
CLEANUP P_CLOSE;
PROCEDURE PSAVE(STRING NDSPC("N:"));
SAVE_NODE(NODESPEC(NDSPC));
! dskin, macro routines, prompt, bcall;
INTEGER DSKINBT;
PROCEDURE IBTINI;
BEGIN
DSKINBT←GETBREAK;
SETBREAK(DSKINBT,";",NULL,"INA");
END;
REQUIRE IBTINI INITIALIZATION;
BOOLEAN BAILTRY; ! *** SO I CAN EXPERIMENT ****;
INTEGER TISUPPRESS; ! used to suppress updating during DSKIN;
INITIALIZE(TISUPPRESS←1);
RECURSIVE PROCEDURE DSKIN(STRING FID);
BEGIN
INTEGER DSKINCH,DSKINBR,DSKINEOF;
EXTERNAL STRING !!QUERY;
DSKINCH←GETCHAN;
OPEN(DSKINCH,"DSK",0,3,0,1000,DSKINBR,DSKINEOF);
LOOKUP(DSKINCH,FID,DSKINEOF);
IF DSKINEOF THEN
ABORT("LOOKUP FAILED FOR FILE "&FID);
IF NOT BAILTRY ∧ TISUPPRESS>0 THEN
!!QUERY←!!QUERY&"UPDSUPPRESS←UPDSUPPRESS+"&CVS(TISUPPRESS)&";";
WHILE NOT DSKINEOF DO
BEGIN
LABEL CHUNKIN;
STRING QQ;
QQ←NULL;
WHILE LENGTH(QQ)<200 ∧ NOT DSKINEOF DO
QQ←QQ&INPUT(DSKINCH,DSKINBT);
CHUNKIN:!!QUERY←!!QUERY&QQ;
IF BAILTRY THEN
BEGIN
INTEGER TIX;
EXTERNAL PROCEDURE BAIL;
TIX←TISUPPRESS;
UPDSUPPRESS←UPDSUPPRESS+TIX;
!!QUERY←!!QUERY&"!!GO;";
BAIL;
UPDSUPPRESS←UPDSUPPRESS-TIX;
END;
END;
IF NOT BAILTRY ∧ TISUPPRESS>0 THEN
!!QUERY←!!QUERY&
"UPDSUPPRESS←UPDSUPPRESS-"&CVS(TISUPPRESS)&";"
&"UPDATE;";
RELEASE(DSKINCH);
END;
RCLASS MACRO(STRING ID,BODY;RPTR(ANY_CLASS) NEXT);
RPTR(MACRO) MACRO_LIST;
STRING LASTMAC; ! name of last macro defined or called;
RPTR(MACRO) PROCEDURE MFIND(STRING ID;BOOLEAN CONSON);
BEGIN
RPTR(MACRO) M;
IF EQU(ID,NULL) THEN
ABORT("macro name not supplied");
M←MACRO_LIST;
WHILE M≠NULL_RECORD DO
BEGIN
IF EQU(MACRO:ID[M],ID) THEN RETURN(M);
M←MACRO:NEXT[M];
END;
IF CONSON THEN
BEGIN
M←NEW_RECORD(MACRO);
MACRO:ID[M]←ID;
MACRO:NEXT[M]←MACRO_LIST;
MACRO_LIST←M;
END;
RETURN(M);
END;
PROCEDURE MDEFQ(STRING ID,BODY);
BEGIN
RPTR(MACRO) M;
M←MFIND(ID,TRUE);
MACRO:BODY[M]←BODY;
LASTMAC←ID;
OUTSTR(ID&" DEFINED. "&CRLF);
END;
PROCEDURE MDEF(STRING ID(NULL));
BEGIN
RPTR(MACRO) M;
EXTERNAL INTEGER _SKIP_;
IF NOT EQU(ID,NULL) THEN LASTMAC←ID;
M←MFIND(LASTMAC,TRUE);
OUTSTR("TYPE IN MACRO BODY. (<ALT> WHEN DONE):");
LODED(MACRO:BODY[M]);MACRO:BODY[M]←NULL;
DO MACRO:BODY[M]←MACRO:BODY[M]&INCHWL
UNTIL _SKIP_=ALT;
OUTSTR(ID&" DEFINED. "&CRLF);
UPDATE;
END;
STRING PROCEDURE MACNAMES;
BEGIN
STRING S;
RPTR(MACRO) M;
S←NULL;
M←MACRO_LIST;
WHILE M≠NULL_RECORD DO
BEGIN
S←S&" "&MACRO:ID[M];
M←MACRO:NEXT[M];
END;
RETURN(S);
END;
INTEGER MPTOP;INITIALIZE(MPTOP←-1);
DEFINE MPMAX=100;
STRING ARRAY MPS[0:MPMAX];
PROCEDURE MPUSH(STRING S);
BEGIN
IF MPTOP=MPMAX THEN
ABORT("PDLOV IN MPUSH");
MPS[MPTOP←MPTOP+1]←S;
END;
STRING PROCEDURE MPGET(INTEGER I);
BEGIN
I←MPTOP-I;
IF I<0 OR I>MPMAX THEN
ABORT("INDEX OUT OF RANGE TO MPGET");
RETURN(MPS[I]);
END;
STRING PROCEDURE MP0;RETURN(MPGET(0));
STRING PROCEDURE MP1;RETURN(MPGET(1));
STRING PROCEDURE MP2;RETURN(MPGET(2));
STRING PROCEDURE MP3;RETURN(MPGET(3));
RECURSIVE PROCEDURE MCALL(STRING ID(NULL));
BEGIN
EXTERNAL STRING !!QUERY;
RPTR(MACRO) M;
INTEGER TIX;
IF NOT EQU(ID,NULL) THEN LASTMAC←ID;
M←MFIND(LASTMAC,FALSE);
IF M=NULL_RECORD THEN
ABORT("MACRO "&ID&" NOT FOUND");
TIX←TISUPPRESS;
UPDSUPPRESS←UPDSUPPRESS+TIX;
!!QUERY←MACRO:BODY[M]&";!!GO;";
BAIL;
UPDSUPPRESS←UPDSUPPRESS-TIX;
LASTMAC←MACRO:ID[M];
UPDATE;
END;
STRING PROCEDURE QQSTR(STRING S);
BEGIN
STRING SS;
INTEGER C;
SS←"""";
WHILE LENGTH(S)>0 DO
BEGIN
C←LOP(S);
IF C="""" THEN
SS←SS&""""""
ELSE
SS←SS&C;
END;
SS←SS&"""";
RETURN(SS);
END;
PROCEDURE MSAVE(STRING ID(NULL));
BEGIN
RPTR(MACRO) M;
PROCEDURE MSAVE1;
BEGIN
OUTSTR("SAVING "&MACRO:ID[M]&" TO "&PCFID&CRLF);
CPRINT(PCH,"MDEFQ(",QQSTR(MACRO:ID[M]),",",
QQSTR(MACRO:BODY[M]),");",CRLF);
END;
IF PCH<0 THEN
BEGIN
OPEN(PCH←GETCHAN,"DSK",0,0,3,0,0,PCEOF);
PCEOF←-1;
WHILE PCEOF DO
BEGIN
OUTSTR("OUTPUT FILE (NULL TO FORGET IT)=");
PCFID←INCHWL;
IF LENGTH(PCFID)=0 THEN
BEGIN
RELEASE(PCH);
PCH←-1;
DONE;
END;
ENTER(PCH,PCFID,PCEOF);
IF PCEOF THEN OUTSTR("ENTER FAILED"&CRLF);
END;
UPDATE;
END;
IF EQU(ID,"*") THEN
BEGIN
M←MACRO_LIST;
WHILE M≠NULL_RECORD DO
BEGIN
MSAVE1;
M←MACRO:NEXT[M];
END;
END
ELSE
BEGIN
IF ¬EQU(ID,NULL) THEN LASTMAC←ID;
M←MFIND(LASTMAC,FALSE);
IF M=NULL_RECORD THEN
ABORT(ID&" not found! ");
MSAVE1;
END;
END;
STRING PROCEDURE PROMPT(STRING S);
BEGIN
OUTSTR(S);
RETURN(INCHWL);
END;
RECURSIVE PROCEDURE BCALL(STRING S1(NULL),S2(NULL));
BEGIN
EXTERNAL STRING !!QUERY;
INTEGER UPDSSAVE;
PROCEDURE UPDSUPREST;UPDSUPPRESS←UPDSSAVE;
CLEANUP UPDSUPREST;
UPDSSAVE←UPDSUPPRESS;
UPDSUPPRESS←0;UPDATE;
OUTSTR(S1);!!QUERY←S2;
;BAIL;
END;
BOOLEAN PROCEDURE ASK(STRING S);
RETURN((PROMPT(S) LAND '137)="Y");
! tree_string, csr_string, astk_string;
BOOLEAN SHOWXFS;INITIALIZE(SHOWXFS←TRUE);
BOOLEAN SHOWLINKS;INITIALIZE(SHOWLINKS←FALSE);
STRING SIMPLE PROCEDURE TBLKSUPPRESS(STRING S);
BEGIN
! a quicker way is to use SCAN, but I don't want to require
any break tables;
STRING SS;INTEGER I,J;
SS←S;J←0;I←0;
WHILE LENGTH(SS) DO
BEGIN
I←I+1;
IF LOP(SS)≠" " THEN J←I;
END;
RETURN(IF J=0 THEN NULL ELSE S[1 FOR J]);
END;
SIMPLE STRING PROCEDURE CVGX(REAL R);
RETURN(TBLKSUPPRESS(CVG(R)));
STRING BLANKS;
SIMPLE PROCEDURE INIBLANKS;
BEGIN
BLANKS←" ";
BLANKS←BLANKS&BLANKS;
BLANKS←BLANKS&BLANKS;
BLANKS←BLANKS&BLANKS;
BLANKS←BLANKS&BLANKS;
END;
REQUIRE INIBLANKS INITIALIZATION [0];
STRING PROCEDURE TSTR(REAL ARRAY XF);
BEGIN
REAL W,PH,TH;
DECODE_ROTATION(XF,W,PH,TH);
RETURN("TR("&CVGX(W)&","&CVGX(PH)&","&CVGX(TH)
&","&CVGX(XF[1,4])&","&CVGX(XF[2,4])&","&CVGX(XF[3,4])
&")");
END;
STRING PROCEDURE OPNDSTR(RPTR(OPND) OP1);
BEGIN
INTEGER RT;
RT←RECTYPE(OP1);
IF RT=LOC(XFELT) THEN
RETURN(TSTR(XFELT:XF[OP1]))
ELSE IF RT=0 THEN
RETURN("NULL!RECORD")
ELSE
ABORT("CANNOT EDIT TYPE");
END;
STRING PROCEDURE NDNAME(RPTR(NODE) ND);
RETURN(IF ND=NULL_RECORD THEN "λ" ELSE NODE:PNAME[ND]);
IFCR HAIRY_VERSION THENC
FORWARD RECURSIVE STRING PROCEDURE TREE_STRING(RPTR(NODE) ND;
INTEGER DEPTH(0),MAXDEPTH(999));
ELSEC
RECURSIVE STRING PROCEDURE TREE_STRING(RPTR(NODE) ND;
INTEGER DEPTH(0),MAXDEPTH(999));
BEGIN
RPTR(STACK) CSR;
STRING TS;
INTEGER L;
DEPTH←DEPTH+1;
IF DEPTH>MAXDEPTH THEN RETURN(NULL);
TS←NULL;
FOR CSR← CURSORS DO
BEGIN
INTEGER PDP;
PDP←STACK:PDP[CSR];
IF PDP≥0 ∧ STACK:A[CSR][PDP]=ND THEN
TS←TS&STACK:ID[CSR];
END;
L←DEPTH*4-LENGTH(TS);
IF L<0 THEN
TS←TS&CRLF&BLANKS[1 FOR DEPTH*4]
ELSE
TS←TS&BLANKS[1 FOR L];
TS←TS&"-+*"[1+NODE:HOWLINKED[ND] FOR 1]&NODE:PNAME[ND];
IF SHOWXFS THEN
TS←TS&" at "&TSTR(NODE:XF[ND]);
IF SHOWLINKS THEN
BEGIN
TS←TS&"[↑"&NDNAME(NODE:DAD[ND])&",↓"&NDNAME(NODE:SON[ND])
&",←"&NDNAME(NODE:EBRO[ND])&",→"&NDNAME(NODE:YBRO[ND])&"]";
END;
TS←TS&CRLF;
ND←ELDEST_SON(ND);
WHILE ND≠NULL_RECORD DO
BEGIN
TS←TS&TREE_STRING(ND,DEPTH,MAXDEPTH);
ND←NODE:YBRO[ND];
END;
RETURN(TS);
END;
ENDC
STRING PROCEDURE CSR_STRING(RPTR(STACK) CSR);
BEGIN
INTEGER I;
STRING CS;
RPTR(NODE) ND;
CS←STACK:ID[CSR]&CRLF;
FOR I←STACK:PDP[CSR] STEP -1 UNTIL 0 DO
BEGIN
INTEGER RT;
CS←CS&CVS(I)&":"&TAB;
ND←STACK:A[CSR][I];
IF ND=NULL_RECORD THEN
CS←CS&"<empty>"&CRLF
ELSE IF (RT←RECTYPE(ND))≠LOC(NODE) THEN
CS←CS&CVRTS(RT)&"."&CVOS(MEMORY[LOCATION(ND)])&CRLF
ELSE
CS←CS&NODE:PNAME[ND]&CRLF;
END;
RETURN(CS);
END;
STRING PROCEDURE ASTK_STRING(RPTR(STACK) ASTK);
BEGIN
STRING S,ID;
INTEGER I,N;
RPTR(OPND) V;
ID←STACK:ID[ASTK];
IF ASTK=LASTARITH THEN
ID←"* "&ID;
S←NULL;
N←-1;
FOR I←STACK:PDP[ASTK] STEP -1 UNTIL 0 DO
BEGIN
INTEGER RT;
IF (N←N+1)>3 THEN DONE;
S←S&ID&CVS(N)&":"&TAB;ID←" ";
V←STACK:A[ASTK][I];
IF (RT←RECTYPE(V))=LOC(XFELT) THEN
S←S&TSTR(XFELT:XF[V])&CRLF
ELSE IF RT=0 THEN
S←S&" < empty > "&CRLF
ELSE
S←S&CVRTS(RT)&"."&CVOS(MEMORY[LOCATION(V)])&CRLF;
END;
RETURN(S);
END;
STRING PROCEDURE OPENFIDS;
BEGIN
STRING S;
S←NULL;
IF ALCH≥0 THEN S←"AL FILE: "&ALFID&" ";
IF PCH≥0 THEN S←S&"P FILE: "&PCFID&" ";
IF LENGTH(LASTMAC)>0 THEN S←S&"LAST MACRO: "&LASTMAC&" ";
RETURN(S&CRLF);
END;
! display routines: tree_print,csr_print,update;
INTEGER MAXDEPTH; ! how deep to display tree;
INTEGER ARRAY DBUF[1:1000];
INTEGER DLMAR,DRMAR,DTMAR,DBMAR; ! whole display area;
INTEGER CLMAR; ! cursor left margin;
INTEGER ATMAR; ! arithmetic dislpay top margin;
INTEGER BTMAR; ! arithmetic dislpay top margin;
INTEGER AFXLINES,ARITHLINES;
INTEGER PPTMAR;
INTEGER CHRSIZE,DPYCSIZE;
INTEGER ARRAY PPINFTBL[0:23];
DEFINE PPIOT "[]" = ['702000000000];
DEFINE PPINFO "[]" = [PPIOT 5,];
BOOLEAN PROCEDURE ONDD;
START_CODE
PPINFO PPINFTBL[0];
MOVE 1,PPINFTBL[2];
TLNN 1,'100000;
TDZA 1,1;
SETO 1,;
END;
SIMPLE PROCEDURE INIAREAS;
BEGIN
CHRSIZE←30; ! I think;
DPYCSIZE←2;
IF ONDD THEN
BEGIN
DLMAR←-625;
DRMAR←550;
END
ELSE
BEGIN
CHRSIZE←20;
DLMAR←-510;
DRMAR←510;
END;
DTMAR←450;
DBMAR←-510;
CLMAR←DRMAR-150;
ATMAR←DBMAR+(DTMAR-DBMAR)/2;
PPTMAR←DBMAR+(DTMAR-DBMAR)*0.20;
BTMAR←(ATMAR-PPTMAR)/2+PPTMAR;
AFXLINES←(DTMAR-ATMAR)/CHRSIZE;
ARITHLINES←(ATMAR-BTMAR)/CHRSIZE;
END;
REQUIRE INIAREAS INITIALIZATION [0];
SIMPLE PROCEDURE DRAWLINE(INTEGER X0,Y0,X1,Y1);
BEGIN
AIVECT(X1,Y1);
AVECT(X0,Y0);
END;
SIMPLE PROCEDURE DRAWBOX(INTEGER X0,Y0,X1,Y1);
BEGIN
AIVECT(X0,Y0);
AVECT(X0,Y1);
AVECT(X1,Y1);
AVECT(X1,Y0);
AVECT(X0,Y0);
END;
PROCEDURE TREE_PRINT(RPTR(NODE) ND);
BEGIN
OUTSTR(TREE_STRING(ND));
END;
PROCEDURE CSR_PRINT(RPTR(STACK) CSR);
OUTSTR(CSR_STRING(CSR));
IFCR ¬HAIRY_VERSION THENC
PROCEDURE UPDATE;
BEGIN
IF UPDSUPPRESS>0 THEN RETURN;
DPYSET(DBUF);
DPYBIG(DPYCSIZE);
TYPLOC(PPTMAR-CHRSIZE,DBMAR);
DRAWBOX(DLMAR,DTMAR,DRMAR,PPTMAR);
DRAWLINE(CLMAR,DTMAR,CLMAR,ATMAR);
DRAWLINE(DLMAR,ATMAR,DRMAR,ATMAR);
DRAWLINE(DLMAR,BTMAR,DRMAR,BTMAR);
TXTBLK(TREE_STRING(CURTREE,0,MAXDEPTH),
DLMAR+5,DTMAR-CHRSIZE-5,
CLMAR-DLMAR-10,AFXLINES);
TXTBLK(ASTK_STRING($ASTACK),
DLMAR+5,ATMAR-CHRSIZE-5,
DRMAR-DLMAR-10,ARITHLINES);
TXTBLK(ASTK_STRING($BSTACK),
DLMAR+5,BTMAR-CHRSIZE-5,
DRMAR-DLMAR-10,ARITHLINES);
TXTBLK( OPENFIDS,
DLMAR+5,PPTMAR+10+CHRSIZE,
DRMAR-DLMAR-10,1);
IF LASTCURSOR≠NULL_RECORD THEN
TXTBLK(CSR_STRING(LASTCURSOR),
CLMAR+5,DTMAR-CHRSIZE-5,
DRMAR-CLMAR-10,AFXLINES-2);
TXTBLK("LAST λ:"&CRLF&" "&LASTλ&CRLF,
CLMAR+5,ATMAR+10+2*CHRSIZE,DRMAR-CLMAR-10,2);
DPYOUT(1);
END;
ENDC
! toplevel, exit;
IFCR ¬HAIRY_VERSION THENC
PROCEDURE TOPLEVEL;
BEGIN
LABEL READY;
PROCEDURE PUNT;
BEGIN
! this procedure is used to escape to toplevel;
GO TO READY;
END;
ESCAPE←NEW;
ASSIGN(ESCAPE,PUNT); ! we hope kick will not be blocked;
! First, some initialzations. ;
WORLD←NEW_NODE("WORLD");
ARM←NEW_NODE("ARM");
POINTER←NEW_NODE("POINTER");
FIDUCIAL←NEW_NODE("FIDUCIAL");
AFX_NODE(ARM,WORLD,NRGLNK);
AFX_NODE(POINTER,ARM,NRGLNK);
AFX_NODE(FIDUCIAL,WORLD,NRGLNK);
PUSHSTK($CURDAD,WORLD);
PUSHSTK($CURPATH,WORLD);
PUSHSTK($CURREF,WORLD);
PUSHSTK($CURMOVE,ARM);
PUSHSTK($CURTREE,WORLD);
PUSHSTK($CURNODE,WORLD);
LASTCURSOR←$CURNODE;
LASTARITH←$ASTACK;
SETFORMAT(0,3);
MAXDEPTH←999;
READARM;
DPYCLR;
DPYSET(DBUF);
TYPLOC(PPTMAR-CHRSIZE,DBMAR);
DPYOUT(1);
! now execute;
READY: UPDSUPPRESS←0;
UPDATE;
OUTSTR("BAIL is your command scanner.");
;BAIL;;
GO TO READY;
END;
ENDC
LABEL XIT;
PROCEDURE EXIT; GO TO XIT;